home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog6.arj / RUBBER.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  4.8 KB  |  188 lines
  1. { rubber.pas -- Click and drag rubberband outlines }
  2.  
  3. program Rubber;
  4.  
  5. {$R rubber.res}
  6.  
  7. uses WinTypes, WinProcs, WObjects;
  8.  
  9. const
  10.  
  11.   id_Menu         = 100;    { Menu resource ID }
  12.   cm_Lines        = 101;    { Menu command values }
  13.   cm_Rectangles   = 102;
  14.   cm_Circles      = 103;
  15.   cm_Clear        = 104;
  16.   cm_Quit         = 105;
  17.  
  18. type
  19.  
  20.   RubberApplication = object(TApplication)
  21.     procedure InitMainWindow; virtual;
  22.   end;
  23.  
  24.   PRubberWindow = ^RubberWindow;
  25.   RubberWindow = object(TWindow)
  26.     DC: Hdc;
  27.     ButtonDown: Boolean;
  28.     X1, Y1, X2, Y2: Integer;
  29.     CurrentObject: Integer;
  30.     OldBrush: HBrush;
  31.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  32.     procedure ShowMouseLocation(X, Y: Integer);
  33.     procedure DrawRubberband;
  34.     procedure WMCommand(var Msg: TMessage);
  35.       virtual wm_First + wm_Command;
  36.     procedure WMLButtonDown(var Msg: TMessage);
  37.       virtual wm_First + wm_LButtonDown;
  38.     procedure WMLButtonUp(var Msg: TMessage);
  39.       virtual wm_First + wm_LButtonUp;
  40.     procedure WMMouseMove(var Msg: TMessage);
  41.       virtual wm_First + wm_MouseMove;
  42.   end;
  43.  
  44.  
  45. {- Toggle a checkmarked menu item on or off }
  46. procedure ToggleCheck(Menu: HMenu; MenuItemID: Word);
  47. var
  48.   MAttr, WCheck: Word;
  49. begin
  50.   MAttr := GetMenuState(Menu, MenuItemID, mf_ByCommand);
  51.   if (MAttr and mf_Checked) = mf_Checked then
  52.     WCheck := mf_ByCommand or mf_Unchecked
  53.   else
  54.     WCheck := mf_ByCommand or mf_Checked;
  55.   CheckMenuItem(Menu, MenuItemID, WCheck)
  56. end;
  57.  
  58.  
  59. { RubberApplication }
  60.  
  61. {- Initialize RubberApplication object's window }
  62. procedure RubberApplication.InitMainWindow;
  63. begin
  64.   MainWindow := New(PRubberWindow, Init(nil, 'Rubber Outlines'))
  65. end;
  66.  
  67.  
  68. { RubberWindow }
  69.  
  70. {- Construct RubberWindow object }
  71. constructor RubberWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  72. begin
  73.   TWindow.Init(AParent, ATitle);
  74.   Attr.Menu := LoadMenu(HInstance, PChar(id_Menu));
  75.   ButtonDown := false;
  76.   CurrentObject := cm_Lines;
  77.   ToggleCheck(Attr.Menu, CurrentObject)
  78. end;
  79.  
  80. {- Display the mouse's "hot spot" location }
  81. procedure RubberWindow.ShowMouseLocation(X, Y: Integer);
  82. var
  83.   SX, SY: String[6];   { Room for Integers in string form }
  84.   S: String[24];       { Both coordinates in string form }
  85. begin
  86.   Str(X:5, SX);
  87.   Str(Y:5, SY);
  88.   S := SX + ' :' + SY + '    ';
  89.   TextOut(DC, 10, 10, @S[1], Length(S))
  90. end;
  91.  
  92. {- Draw rubberband outline while dragging mouse }
  93. procedure RubberWindow.DrawRubberband;
  94. begin
  95.   MoveTo(DC, X1, Y1);
  96.   case CurrentObject of
  97.     cm_Lines: LineTo(DC, X2, Y2);
  98.     cm_Rectangles: Rectangle(DC, X1, Y1, X2, Y2);
  99.     cm_Circles: Ellipse(DC, X1, Y1, X2, Y2);
  100.   end
  101. end;
  102.  
  103. {- Respond to left mouse button down events }
  104. procedure RubberWindow.WMLButtonDown(var Msg: TMessage);
  105. begin
  106.   if not ButtonDown then with Msg do
  107.   begin
  108.     DC := GetDC(HWindow);
  109.     ShowMouseLocation(LOWORD(LParam), HIWORD(LParam));  {i.e. X, Y}
  110.     X1 := LParamLo;
  111.     Y1 := LParamHi;
  112.     X2 := X1;
  113.     Y2 := Y1;
  114.     OldBrush:= SelectObject(DC, GetStockObject(hollow_Brush));
  115.     SetROP2(DC, r2_Not);
  116.     DrawRubberband;
  117.     ButtonDown := true;
  118.     SetCursor(LoadCursor(0, idc_Cross));
  119.     SetCapture(HWindow)
  120.   end
  121. end;
  122.  
  123. {- Respond to left mouse button up events }
  124. procedure RubberWindow.WMLButtonUp(var Msg: TMessage);
  125. begin
  126.   if ButtonDown then with Msg do
  127.   begin
  128.     DrawRubberband;
  129.     ButtonDown := false;
  130.     SetROP2(DC, r2_Black);
  131.     DrawRubberband;  { Draw visible object }
  132.     SelectObject(DC, OldBrush);
  133.     SetCursor(LoadCursor(0, idc_Arrow));
  134.     ReleaseDC(HWindow, DC);
  135.     ReleaseCapture
  136.   end
  137. end;
  138.  
  139. {- Respond to mouse-movement event }
  140. procedure RubberWindow.WMMouseMove(var Msg: TMessage);
  141. begin
  142.   if ButtonDown then with Msg do
  143.   begin
  144.     ShowMouseLocation(LOWORD(LParam), HIWORD(LParam));  {i.e. X, Y}
  145.     DrawRubberband;    { Erase old line }
  146.     with Msg do
  147.     begin
  148.       X2 := LParamLo;
  149.       Y2 := LParamHi;
  150.       DrawRubberband   { Draw new line }
  151.     end
  152.   end
  153. end;
  154.  
  155. {- Intercept wm_Command messages }
  156. procedure RubberWindow.WMCommand(var Msg: TMessage);
  157. begin
  158.   with Msg do
  159.   case WParam of
  160.     cm_Lines, cm_Rectangles, cm_Circles:
  161.       begin
  162.         ToggleCheck(Attr.Menu, CurrentObject);
  163.         CurrentObject := WParam;
  164.         ToggleCheck(Attr.Menu, CurrentObject)
  165.       end;
  166.     cm_Clear: InvalidateRect(HWindow, nil, true);
  167.     cm_Quit: CloseWindow
  168.   else
  169.     TWindow.WMCommand(Msg)
  170.   end
  171. end;
  172.  
  173. var
  174.  
  175.   RubberApp: RubberApplication;
  176.  
  177. begin
  178.   RubberApp.Init('RubberApp');
  179.   RubberApp.Run;
  180.   RubberApp.Done
  181. end.
  182.  
  183.  
  184. {--------------------------------------------------------------
  185.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  186.   Revision 1.00    Date: 3/09/1991
  187. ---------------------------------------------------------------}
  188.